Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/PNL Libraries/MyPreferences.p

Text File | 1994-09-27 | 5.3 KB | 212 lines | [TEXT/PJMM]

unit MyPreferences;

interface

    procedure GetPrefsFolderFSSpec (var fs: FSSpec);
    procedure GetPrefsFSSpec (var fs: FSSpec);
    function OpenPrefsFile (fs: FSSpec): integer;
    function MakePrefsFile (fs: FSSpec): integer;
    procedure GetPrefs (var prefs: prefsRecord);
    procedure SetPrefs (var prefs: prefsRecord);
    procedure JustGetPrefs (var prefs: prefsRecord);
    procedure JustSetPrefs (var prefs: prefsRecord);
    function GetPrefsResource (res: resType; id: integer; var h: handle): integer;
    procedure SetPrefsResource (res: resType; id: integer; h: handle);

implementation

    uses
        Folders, AppleTalk, Aliases;

    procedure MyResolveAliasFile (var fs: FSSpec); { * }
        var
            isfolder, wasalias: boolean;
            oe: OSErr;
            temp: FSSpec;
            has_aliasMgr: boolean;
            gv: longInt;
    begin
        oe := Gestalt(gestaltAliasMgrAttr, gv);
        has_aliasMgr := (oe = noErr) and (BTST(gv, gestaltAliasMgrPresent));
        if has_aliasMgr then begin
            temp := fs;
            oe := ResolveAliasFile(fs, true, isfolder, wasalias);
            if oe <> noErr then
                fs := temp;
        end;
    end;

    procedure GetPrefsFolderFSSpec (var fs: FSSpec);
        var
            gv: longInt;
            oe: OSErr;
            pb: HParamBlockRec;
            sysenv: SysEnvRec;
    begin
        if (Gestalt(gestaltFindFolderAttr, gv) <> noErr) | (not BTST(gv, gestaltFindFolderPresent)) | (FindFolder(kOnSystemDisk, kPreferencesFolderType, kCreateFolder, fs.vRefNum, fs.parID) <> NoErr) then begin
            oe := SysEnvirons(1, sysenv);
            with pb do begin
                fs.vRefNum := sysenv.sysVRefNum;
                fs.name := 'Preferences';
                if DirCreate(sysenv.sysVRefNum, 0, fs.name, fs.parID) <> noErr then begin
                    ioNamePtr := @fs.name;
                    ioVRefNum := fs.vRefNum;
                    ioDirID := 0;
                    ioFDirIndex := 0;
                    if (PBGetCatInfo(@pb, false) = noErr) & (BAND(ioFlAttrib, $0010) <> 0) then
                        fs.parID := pb.ioDirID
                    else
                        fs.parID := 0;
                end;
            end;
        end;
        fs.name := '';
    end;

    procedure GetPrefsFSSpec (var fs: FSSpec);
        var
            oe: OSErr;
            pb: HParamBlockRec;
            s: str255;
            dummy: longInt;
    begin
        GetPrefsFolderFSSpec(fs);
        if prefsFolderStrhIndex > 0 then begin
            GetIndString(s, prefsStrhResID, prefsFolderStrhIndex);
            fs.name := s;
            oe := DirCreate(fs.vRefNum, fs.parID, fs.name, dummy);
            MyResolveAliasFile(fs);
            with pb do begin
                ioNamePtr := @fs.name;
                ioVRefNum := fs.vRefNum;
                ioDirID := fs.parID;
                ioFDirIndex := 0;
                if (PBGetCatInfo(@pb, false) = noErr) & (BAND(ioFlAttrib, $0010) <> 0) then
                    fs.parID := pb.ioDirID;
            end;
        end;
        GetIndString(s, prefsStrhResID, prefsNameStrhIndex);
        fs.name := s;
    end;

    function OpenPrefsFile (fs: FSSpec): integer;
    begin
        MyResolveAliasFile(fs);
        OpenPrefsFile := HOpenResFile(fs.vRefNum, fs.parID, fs.name, fsRdPerm);
    end;

    function MakePrefsFile (fs: FSSpec): integer;
        const
            finderLaunchStrID = -16397;
        var
            oe: OSErr;
            sh: stringHandle;
            s: str255;
            rn: integer;
    begin
        MyResolveAliasFile(fs);
        oe := HCreate(fs.vRefNum, fs.parID, fs.name, prefsCreator, 'pref');
        HCreateResFile(fs.vRefNum, fs.parID, fs.name);
        rn := HOpenResFile(fs.vRefNum, fs.parID, fs.name, fsRdWrPerm);
        if rn <> -1 then begin
            sh := stringHandle(Get1Resource('STR ', finderLaunchStrID));
            if sh = nil then begin
                GetIndString(s, prefsStrhResID, prefsFinderCommentStrhIndex);
                sh := NewString(s);
                if sh <> nil then
                    AddResource(handle(sh), 'STR ', finderLaunchStrID, 'Finder launch string');
            end;
        end;
        MakePrefsFile := rn;
    end;

    type
        prefsPtr = ^prefsRecord;
        prefsHandle = ^prefsPtr;

    procedure GetPrefs (var prefs: prefsRecord);
        var
            h: handle;
    begin
        h := GetResource(prefsResType, prefsResID);
        prefs.version := -1;
        if (h <> nil) & (GetHandleSize(h) = SizeOf(prefsRecord)) then
            prefs := prefsHandle(h)^^;
        ValidatePrefs(prefs);
    end;

    procedure SetPrefs (var prefs: prefsRecord);
        var
            h: handle;
    begin
        h := Get1Resource(prefsResType, prefsResID);
        if h = nil then begin
            h := NewHandle(SizeOf(prefsRecord));
            if h <> nil then
                AddResource(h, prefsResType, prefsResID, 'Prefs');
        end;
        if h <> nil then begin
            SetHandleSize(h, SizeOf(prefsRecord));
            prefsHandle(h)^^ := prefs;
            ChangedResource(h);
        end;
    end;

    procedure JustGetPrefs (var prefs: prefsRecord);
        var
            prefs_fs: FSSpec;
            prefs_rn: integer;
    begin
        GetPrefsFSSpec(prefs_fs);
        prefs_rn := OpenPrefsFile(prefs_fs);
        GetPrefs(prefs);
        if prefs_rn <> -1 then
            CloseResFile(prefs_rn);
    end;

    procedure JustSetPrefs (var prefs: prefsRecord);
        var
            prefs_fs: FSSpec;
            prefs_rn: integer;
    begin
        GetPrefsFSSpec(prefs_fs);
        prefs_rn := MakePrefsFile(prefs_fs);
        if prefs_rn <> -1 then begin
            SetPrefs(prefs);
            CloseResFile(prefs_rn);
        end;
    end;

    function GetPrefsResource (res: resType; id: integer; var h: handle): integer;
        var
            prefs_fs: FSSpec;
            prefs_rn: integer;
    begin
        GetPrefsFSSpec(prefs_fs);
        prefs_rn := OpenPrefsFile(prefs_fs);
        h := GetResource(res, id);
        GetPrefsResource := prefs_rn;
    end;

    procedure SetPrefsResource (res: resType; id: integer; h: handle);
        var
            prefs_fs: FSSpec;
            prefs_rn: integer;
            h2: handle;
    begin
        if h <> nil then begin
            GetPrefsFSSpec(prefs_fs);
            prefs_rn := MakePrefsFile(prefs_fs);
            if prefs_rn <> -1 then begin
                h2 := Get1Resource(res, id);
                if h2 <> nil then begin
                    RmveResource(h2);
                    DisposHandle(h2);
                end;
                AddResource(h, res, id, '');
                CloseResFile(prefs_rn);
            end;
        end;
    end;

end.